BBS in a Box 15/BBS in a box XV-1.iso/Files/Tele/Pete Johnson/Mehit 3.0.b15<source>.sit/DebugDialog.p

Text File | 1991-07-10 | 6.6 KB | 265 lines | [TEXT/PJMM]

unit Debug;

{Written by Pete Johnson 6/23/91}

{Creates and updates a debug status window using no resources. Use debugStr1,  debugStr2 and debugStr3     }
{for status messages. Also shows free memory, last memory error and resource error codes.                        }

{Use:}
{Call SetupDebug, assign strings to the three debugStr variables and call Update Debug. When finished, call        }
{KillDebug. Other handy calls:                                                                                                                        }
{    SetDebugStrings(str1,str2,str3) lets you set all three debug strings in one call                                            }
{    ShowErrStr returns a decoded error or a string of the error number                                                            }

interface

var
    debugWindow: WindowPtr;
    debugStr1, debugStr2, debugStr3: str255;
    debugCounter: longint;

procedure SetupDebug;

procedure SetDebugStrings (string1, string2, string3: str255);

function ShowErrStr (theErr: integer): str255;

procedure UpdateDebug;

procedure IncrementDebug;

procedure WaitDebug;

procedure CloseDebug;

implementation

{ ================================  RedrawRect  ================================ }

procedure RedrawRect (theRect: rect; L, T, R, B: integer);

    begin
        SetRect(theRect, L, T, R, B);    {left, top, right, bottom}
        FrameRect(theRect);
        InsetRect(theRect, 1, 1);
        EraseRect(theRect)
    end;

{ ================================  ShowErrString  ================================ }

function ShowErrStr;{(theErr:integer): str255}
    {returns decoded error code or a string of the error number}

    begin
        case theErr of
            tmwdoErr:
                ShowErrStr := 'too many wdir open';
            dirNFErr:
                ShowErrStr := 'dir not found';
            fsRnErr:
                ShowErrStr := 'can''t rename file';
            permErr:
                ShowErrStr := 'can''t write locked file';
            volOffLinErr:
                ShowErrStr := 'vol not on line';
            rfNumErr:
                ShowErrStr := 'no such path';
            paramErr:
                ShowErrStr := 'no default vol';
            vLckdErr:
                ShowErrStr := 'file locked';
            fLckdErr, wPrErr:
                ShowErrStr := 'volume locked';
            fnfErr:
                ShowErrStr := 'file not found';
            tmfoErr:
                ShowErrStr := 'too many files open';
            posErr:
                ShowErrStr := 'position error';
            eofErr:
                ShowErrStr := 'hit eof on read';
            fnOpnErr:
                ShowErrStr := 'file not open';
            bdNamErr:
                ShowErrStr := 'bad file/vol name';
            ioErr:
                ShowErrStr := 'i/o error';
            nsvErr:
                ShowErrStr := 'no such vol';
            dskFulErr:
                ShowErrStr := 'disk full';
            dirFulErr:
                ShowErrStr := 'directory full';
            memLockedErr:
                ShowErrStr := 'locked block';
            nilHandleErr:
                ShowErrStr := 'nil master pointer';
            memFullErr:
                ShowErrStr := 'no room in heap';
            noErr:
                ShowErrStr := 'no error';
            otherwise
                ShowErrStr := stringOf(theErr : 1)
        end    {case}
    end;

{ ================================  SetDebugStrings  ================================ }

procedure SetDebugStrings;{(string1, string2, string3: str255)}

    begin
        debugStr1 := string1;
        debugStr2 := string2;
        debugStr3 := string3
    end;

{ ================================  KillDebug  ================================ }

procedure CloseDebug;

    begin
        if debugWindow <> nil then
            begin
                DisposeWindow(debugWindow);
                debugWindow := nil
            end;
    end;

{ ================================  UpdateDebug  ================================ }

procedure UpdateDebug;

    var
        rect1, rect2, rect3, rect4, rect5, rect6: rect;
        freeBytes: longint;
        oldPort: grafPtr;

    begin
        if debugWindow <> nil then
            begin
                GetPort(oldPort);
                SetPort(debugWindow);
                textFont(Geneva);
                textSize(9);
                ForeColor(redColor);
                RedrawRect(rect1, 5, 4, 180, 18);            {left, top, right, bottom}
                RedrawRect(rect2, 5, 20, 180, 34);            {left, top, right, bottom}
                RedrawRect(rect3, 5, 36, 180, 50);            {left, top, right, bottom}
                RedrawRect(rect4, 5, 52, 62, 66);            {left, top, right, bottom}
                RedrawRect(rect5, 64, 52, 121, 66);        {left, top, right, bottom}
                RedrawRect(rect6, 123, 52, 180, 66);        {left, top, right, bottom}
                MoveTo(9, 14);
                DrawString(debugStr1);
                MoveTo(9, 30);
                DrawString(debugStr2);
                MoveTo(9, 46);
                DrawString(debugStr3);
                freeBytes := FreeMem;
                MoveTo(9, 62);
                DrawString(concat(stringOf(freeBytes div 1024 : 1), 'K'));
                MoveTo(68, 62);
                DrawString(concat('M: ', stringOf(MemError : 1)));
                MoveTo(127, 62);
                DrawString(concat('R: ', stringOf(ResError : 1)));
                SetPort(oldPort)
            end
    end;

{ ================================  WaitDebug  ================================ }

procedure WaitDebug;

    const
        sleep = 10;

    var
        mouseLoc: point;
        clickInWindow: boolean;
        theEvent: EventRecord;
        whichWindow: WindowPtr;
        result: integer;

    begin
        if debugWindow <> nil then
            begin
                clickInWindow := false;
                UpdateDebug;
                repeat
                    if WaitNextEvent(mDownMask, theEvent, sleep, nil) then
                        begin
                            result := FindWindow(theEvent.where, whichWindow);
                            if whichWindow = debugWindow then
                                begin
                                    case theEvent.what of
                                        mouseDown:
                                            case result of
                                                activateEvt:
                                                    begin
                                                        SelectWindow(whichWindow);
                                                        UpdateDebug;
                                                    end;
                                                inContent:
                                                    clickInWindow := true;
                                                inDrag:
                                                    begin
                                                        DragWindow(whichWindow, theEvent.where, screenbits.bounds);
                                                        UpdateDebug;
                                                    end;
                                                otherwise
                                                    ;
                                            end;
                                        otherwise
                                            ;
                                    end
                                end
                        end;
                until clickInWindow;
                if button then
                    repeat
                    until not button
            end
    end;

{ ================================  IncrementDebug  ================================ }

procedure IncrementDebug;

    begin
        if debugWindow <> nil then
            begin
                debugCounter := succ(debugCounter);
                debugStr3 := concat('Checkpoint #', stringOf(debugCounter : 1), '   Click to continue …');
                WaitDebug
            end
    end;

{ ================================   SetUp   ================================ }

procedure SetupDebug;

    const
        debugHeight = 69;        {height of debug window}
        debugWidth = 184;    {width of debug window}

    var
        wRect: rect;
        title: str255;
        itemList: handle;
        itemHit: integer;
        oldPort: GrafPtr;
        debugV, debugH: integer;

    begin
        GetPort(oldPort);
        SetDebugStrings('', '', '');
        debugCounter := 0;
{                        next few lines put window at bottom left of screen            }
        debugV := Screenbits.bounds.bottom - debugHeight;
        debugH := Screenbits.bounds.right - debugWidth;
        SetRect(wRect, debugH, debugV, debugH + debugWidth, debugV + debugHeight);    {left, top, right, bottom}
        title := 'Debug';
        debugWindow := NewWindow(nil, wRect, title, true, NoGrowDocProc, Pointer(-1), false, longint('Pete'));
        ShowWindow(debugWindow);
        SetPort(oldPort)
    end;
end.